home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / b / b.lha / B / src / bint / b3loc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1988-11-24  |  10.3 KB  |  354 lines

  1. /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1985. */
  2.  
  3. /*
  4.   $Header: b3loc.c,v 1.4 85/08/27 10:56:45 timo Exp $
  5. */
  6.  
  7. /* B locations and environments */
  8. #include "b.h"
  9. #include "b0con.h"
  10. #include "b1obj.h"
  11. #include "b3env.h" /* for bndtgs */
  12. #include "b3sem.h"
  13. #include "b3sou.h" /* for tarvalue() */
  14. #include "b3err.h" /* for still_ok */
  15.  
  16. Hidden value* location(l) loc l; {
  17.     value *ll;
  18.     if (Is_locloc(l)) {
  19.         if (!in_env(curnv->tab, l, &ll))
  20.             error(MESS(3600, "target not initialised"));
  21.         return ll;
  22.     } else if (Is_simploc(l)) {
  23.         simploc *sl= Simploc(l);
  24.         if (!in_env(sl->e->tab, sl->i, &ll))
  25.             if (Is_locloc(sl->i))
  26.                 error(MESS(3601, "target not initialised"));
  27.             else error3(0, sl->i,
  28.                 MESS(3602, " hasn't been initialised"));
  29.         return ll;
  30.     } else if (Is_tbseloc(l)) {
  31.         tbseloc *tl= Tbseloc(l);
  32.         ll= location(tl->R);
  33.         if (still_ok) {    
  34.             ll= adrassoc(*ll, tl->K);
  35.             if (ll == Pnil && still_ok) error(MESS(3603, "key not in table"));
  36.         }
  37.         return ll;
  38.     } else {
  39.         syserr(MESS(3604, "call of location with improper type"));
  40.         return (value *) Dummy;
  41.     }
  42. }
  43.  
  44. Hidden Procedure uniquify(l) loc l; {
  45.     if (Is_simploc(l)) {
  46.         simploc *sl= Simploc(l);
  47.         value *ta= &(sl->e->tab), ke= sl->i;
  48.         uniql(ta);
  49.         check_location(l);
  50.         if (still_ok) {
  51.             if (Is_compound(*ta)) uniql(Field(*ta, intval(ke)));
  52.             else {    value *aa, v;
  53.                 VOID uniq_assoc(*ta, ke);
  54.                 aa= adrassoc(*ta, ke);
  55.                 v= copy(tarvalue(ke, *aa));
  56.                 release(*aa);
  57.                 *aa= v;
  58.                 uniql(aa);
  59.             }
  60.         }
  61.     } else if (Is_tbseloc(l)) {
  62.         tbseloc *tl= Tbseloc(l);
  63.         value t, ke;
  64.         uniquify(tl->R);
  65.         if (still_ok) { t= *location(tl->R); ke= tl->K; }
  66.         if (still_ok) {
  67.             if (!Is_table(t)) error(MESS(3605, "selection on non-table"));
  68.             else if (empty(t)) error(MESS(3606, "selection on empty table"));
  69.             else {
  70.                 check_location(l);
  71.                 if (still_ok) VOID uniq_assoc(t, ke);
  72.             }
  73.         }
  74.     } else if (Is_trimloc(l)) { syserr(MESS(3607, "uniquifying trimloc"));
  75.     } else if (Is_compound(l)) { syserr(MESS(3608, "uniquifying comploc"));
  76.     } else syserr(MESS(3609, "uniquifying non-location"));
  77. }
  78.  
  79. Visible Procedure check_location(l) loc l; {
  80.     VOID location(l);
  81.     /* location may produce an error message */
  82. }
  83.  
  84. Visible value content(l) loc l; {
  85.     value *ll= location(l);
  86.     return still_ok ? copy(*ll) : Vnil;
  87. }
  88.  
  89. Visible loc trim_loc(l, v, sign) loc l; value v; char sign; {
  90.     loc root, res; value text, B, C;
  91.     if (Is_simploc(l) || Is_tbseloc(l)) {
  92.         uniquify(l); /* Call tarvalue at proper time */
  93.         root= l;
  94.         B= zero; C= zero;
  95.     } else if (Is_trimloc(l)) {
  96.         trimloc *rr= Trimloc(l);
  97.         root= rr->R;
  98.         B= rr->B; C= rr->C;
  99.     } else {
  100.         error(MESS(3610, "trim (@ or |) on target of improper type"));
  101.         return Lnil;
  102.     }
  103.     text= content(root);
  104.     if (!still_ok);
  105.     else if (!Is_text(text)) {
  106.         error(MESS(3611, "in the target t@p or t|p, t does not contain a text"));
  107.     } else {
  108.         value s= size(text), w, x, b_plus_c;
  109.         if (sign == '@') B= sum(B, w=diff(v, one));
  110.         else {    C= sum(C, w=diff(x= diff(s, B), v)); release(x); }
  111.         release(w);
  112.         b_plus_c= sum(B, C);
  113.         if (still_ok && (compare(B,zero)<0 || compare(C,zero)<0
  114.                   || compare(b_plus_c,s)>0))
  115.             error(MESS(3612, "in the target t@p or t|p, p is out of bounds"));
  116.         else res= mk_trimloc(root, B, C);
  117.         if (sign == '@') release(B); 
  118.         else release(C);
  119.         release(s); release(b_plus_c);
  120.     }
  121.     release(text);
  122.     if (still_ok) return res; else return Lnil;
  123. }
  124.  
  125. Visible loc tbsel_loc(R, K) loc R; value K; {
  126.     if (Is_simploc(R) || Is_tbseloc(R)) return mk_tbseloc(R, K);
  127.     else error(MESS(3613, "selection on target of improper type"));
  128.     return Lnil;
  129. }
  130.  
  131. Visible loc local_loc(i) basidf i; { return mk_simploc(i, curnv); }
  132.  
  133. Visible loc global_loc(i) basidf i; { return mk_simploc(i, prmnv); }
  134.  
  135. Hidden Procedure put_trim(v, tl) value v; trimloc *tl; {
  136.     value rr, nn, head, tail, part;
  137.     value B= tl->B, C= tl->C, len, len_minus_c, tail_start;
  138.     rr= *location(tl->R);
  139.     len= size(rr);
  140.     len_minus_c= diff(len, C); release(len);
  141.     tail_start= sum(len_minus_c, one); release(len_minus_c);
  142.     if (compare(B, zero)<0 || compare(C, zero)<0
  143.      || compare(B, tail_start)>=0)
  144.         error(MESS(3614, "trim (@ or |) on text location out of bounds"));
  145.     else {
  146.         head= curtail(rr, B); /* rr|B */
  147.         tail= behead(rr, tail_start); /* rr@(#rr-C+1) */
  148.         part= concat(head, v); release(head);
  149.         nn= concat(part, tail); release(part); release(tail);
  150.         put(nn, tl->R); release(nn);
  151.     }
  152.     release(tail_start);
  153. }
  154.  
  155. Visible Procedure put(v, l) value v; loc l; {
  156.     if (Is_locloc(l)) {
  157.         e_replace(v, &curnv->tab, l);
  158.     } else if (Is_simploc(l)) {
  159.         simploc *sl= Simploc(l);
  160.         e_replace(v, &(sl->e->tab), sl->i);
  161.     } else if (Is_trimloc(l)) {
  162.         if (!Is_text(v)) error(MESS(3615, "putting non-text in trim (@ or |)"));
  163.         else put_trim(v, Trimloc(l));
  164.     } else if (Is_compound(l)) {
  165.         intlet k, len= Nfields(l);
  166.         if (!Is_compound(v))
  167.             error(MESS(3616, "putting non-compound in compound location"));
  168.         else if (Nfields(v) != Nfields(l))
  169.             error(MESS(3617, "putting compound in compound location of different length"));
  170.         else k_Overfields { put(*Field(v, k), *Field(l, k)); }
  171.     } else if (Is_tbseloc(l)) {
  172.         tbseloc *tl= Tbseloc(l); value *rootloc;
  173.         uniquify(tl->R);
  174.         if (still_ok) {
  175.             rootloc= location(tl->R);
  176.             if (still_ok && !Is_table(*rootloc))
  177.                 error(MESS(3621, "selection on non-table"));
  178.             if (still_ok) replace(v, rootloc, tl->K);
  179.         }
  180.     } else error(MESS(3618, "putting in non-target"));
  181. }
  182.  
  183. /* Check for correct effect of multiple put-command: catches PUT 1, 2 IN x, x.  
  184.    The assignment cannot be undone, but this is not considered a problem.
  185.    For trimmed-texts, no checks are made because the language definition
  186.    itself causes problem (try PUT "abc", "" IN x@2|1, x@3|1). */
  187.  
  188. Hidden bool putck(v, l) value v; loc l; {
  189.     intlet k, len; value w;
  190.     if (!still_ok) return No;
  191.     if (Is_compound(l)) {
  192.         if (!Is_compound(v) || Nfields(v) != (len= Nfields(l)))
  193.             return No; /* Severe type error */
  194.         k_Overfields
  195.             { if (!putck(*Field(v, k), *Field(l, k))) return No; }
  196.         return Yes;
  197.     }
  198.     if (Is_trimloc(l)) return Yes; /* Don't check trim locations */
  199.     w= *location(l);
  200.     /* Unfortunately, this may already cause an error, e.g. after
  201.        PUT 1, {} IN t[1], t.  This can't be helped unless we introduce
  202.        a flag so that location will shut up. */
  203.     return still_ok && compare(v, w) == 0;
  204. }
  205.  
  206. /* The check can't be called from within put because put is recursive,
  207.    and so is the check: then, for the inner levels the check would be done
  208.    twice.  Moreover, we don't want to clutter up put, which is called
  209.    internally in, many places. */
  210.  
  211. Visible Procedure put_with_check(v, l) value v; loc l; {
  212.     intlet i, k, len; bool ok;
  213.     put(v, l);
  214.     if (!still_ok || !Is_compound(l))
  215.         return; /* Single target can't be wrong */
  216.     len= Nfields(l); ok= Yes;
  217.     /* Quick check for putting in all different local targets: */
  218.     k_Overfields {
  219.         if (!IsSmallInt(*Field(l, k))) { ok= No; break; }
  220.         for (i= k-1; i >= 0; --i) {
  221.             if (*Field(l, i) == *Field(l, k)) { ok= No; break; }
  222.         }
  223.         if (!ok) break;
  224.     }
  225.     if (ok) return; /* All different local basic-targets */
  226.     if (!putck(v, l))
  227.         error(MESS(3619, "putting different values in same location"));
  228. }
  229.  
  230.  
  231. Hidden bool l_exists(l) loc l; {
  232.     if (Is_simploc(l)) {
  233.         simploc *sl= Simploc(l);
  234.         return envassoc(sl->e->tab, sl->i) != Pnil;
  235.     } else if (Is_trimloc(l)) {
  236.         error(MESS(3620, "deleting trimmed (@ or |) target"));
  237.         return No;
  238.     } else if (Is_compound(l)) {
  239.         intlet k, len= Nfields(l);
  240.         k_Overfields { if (!l_exists(*Field(l, k))) return No; }
  241.         return Yes;
  242.     } else if (Is_tbseloc(l)) {
  243.         tbseloc *tl= Tbseloc(l); value *ll;
  244.         uniquify(tl->R); /* call tarvalue() at proper place */
  245.         if (still_ok) ll= location(tl->R);
  246.         if (still_ok && !Is_table(*ll))
  247.             error(MESS(3621, "selection on non-table"));
  248.         return still_ok && in_keys(tl->K, *ll);
  249.     } else {
  250.         error(MESS(3622, "deleting non-target"));
  251.         return No;
  252.     }
  253. }
  254.  
  255. /* Delete a location if it exists */
  256.  
  257. Hidden Procedure l_del(l) loc l; {
  258.     if (Is_simploc(l)) {
  259.         simploc *sl= Simploc(l);
  260.         e_delete(&(sl->e->tab), sl->i);
  261.     } else if (Is_trimloc(l)) {
  262.         error(MESS(3623, "deleting trimmed (@ or |) target"));
  263.     } else if (Is_compound(l)) {
  264.         intlet k, len= Nfields(l);
  265.         k_Overfields { l_del(*Field(l, k)); }
  266.     } else if (Is_tbseloc(l)) {
  267.         tbseloc *tl= Tbseloc(l);
  268.         value *lc;
  269.         uniquify(tl->R);
  270.         if (still_ok) {
  271.             lc= location(tl->R);
  272.             if (in_keys(tl->K, *lc)) delete(lc, tl->K);
  273.         }
  274.     } else error(MESS(3624, "deleting non-target"));
  275. }
  276.  
  277. Visible Procedure l_delete(l) loc l; {
  278.     if (l_exists(l)) l_del(l);
  279.     else if (still_ok) error(MESS(3625, "deleting non-existent target"));
  280. }
  281.  
  282. Visible Procedure l_insert(v, l) value v; loc l; {
  283.     value *ll;
  284.     uniquify(l);
  285.     if (still_ok) {
  286.         ll= location(l);
  287.         if (!Is_list(*ll)) error(MESS(3626, "inserting in non-list"));
  288.         else insert(v, ll);
  289.     }
  290. }
  291.  
  292. Visible Procedure l_remove(v, l) value v; loc l; {
  293.     value *ll;
  294.     uniquify(l);
  295.     if (still_ok) {
  296.         ll= location(l);
  297.         if (!Is_list(*ll)) error(MESS(3627, "removing from non-list"));
  298.         else if (empty(*ll)) error(MESS(3628, "removing from empty list"));
  299.         else remove(v, ll);
  300.     }
  301. }
  302.  
  303. /* Warning: choose is only as good as the accuracy of the random-number */
  304. /* generator. In particular, for very large values of v, elements will  */
  305. /* be chosen unfairly. Choose should be rewritten to cope with this     */
  306.  
  307. Visible Procedure choose(l, v) loc l; value v; {
  308.     value w, s, r;
  309.     if (!Is_tlt(v)) error(MESS(3629, "choosing from non-text, -list or -table"));
  310.     else if (empty(v)) error(MESS(3630, "choosing from empty text, list or table"));
  311.     else {
  312.         /* PUT (floor(random*#v) + 1) th'of v IN l */
  313.         s= size(v);
  314.         r= prod(w= random(), s); release(w); release(s);
  315.         w= floorf(r); release(r);
  316.         r= sum(w, one); release(w);
  317.         put(w= th_of(r, v), l); release(w); release(r);
  318.     }
  319. }
  320.  
  321. Visible Procedure draw(l) loc l; {
  322.     value r= random();
  323.     put(r, l);
  324.     release(r);
  325. }
  326.  
  327. Visible Procedure bind(l) loc l; {
  328.     if (*bndtgs != Vnil) {
  329.         if (Is_simploc(l)) {
  330.             simploc *ll= Simploc(l);
  331.             if (!in(ll->i, *bndtgs)) /* kludge */ /* what for? */
  332.                 insert(ll->i, bndtgs);
  333.         } else if (Is_compound(l)) {
  334.             intlet k, len= Nfields(l);
  335.             k_Overfields { bind(*Field(l, k)); }
  336.         } else error(MESS(3631, "binding non-identifier"));
  337.     }
  338.     l_del(l);
  339. }
  340.  
  341. Visible Procedure unbind(l) loc l; {
  342.     if (*bndtgs != Vnil) {
  343.         if (Is_simploc(l)) {
  344.             simploc *ll= Simploc(l);
  345.             if (in(ll->i, *bndtgs))
  346.                 remove(ll->i, bndtgs);
  347.         } else if (Is_compound(l)) {
  348.             intlet k, len= Nfields(l);
  349.             k_Overfields { unbind(*Field(l, k)); }
  350.         } else error(MESS(3632, "unbinding non-identifier"));
  351.     }
  352.     l_del(l);
  353. }
  354.